home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / xmandel.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  16.3 KB  |  511 lines
  1. #! /usr/local/bin/xmscm
  2. ;
  3. ; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xmandel.scm,v 1.7 1992/08/18 00:29:38 campbell Beta $
  4. ;
  5. ; Sample xmscm program for computing and displaying a Mandelbrot set
  6. ; (actually, the points _near_ the Mandelbrot set;  points in the set
  7. ; itself come out black).
  8. ;
  9. ;  Author: Larry Campbell (campbell@redsox.bsw.com)
  10. ; 
  11. ;  Copyright 1992 by The Boston Software Works, Inc.
  12. ;  Permission to use for any purpose whatsoever granted, as long
  13. ;  as this copyright notice remains intact.  Please send bug fixes
  14. ;  or enhancements to the above email address.
  15.  
  16. (require 'format)
  17.  
  18. (require 'x11)
  19. (require 'xt)
  20. (require 'xm)
  21. (require 'xmsubs)
  22. (require 'xevent)
  23.  
  24. (define call/cc call-with-current-continuation)        ; save typing
  25.  
  26. (define origin '())            ; center of area being drawn
  27. (define depth '())            ; how many iterations before giving up
  28. (define width 0)            ; width in pixels of drawing area
  29. (define height 0)            ; height in pixels of drawing area
  30. (define magnification '())        ; how much to magnify (zoom in)
  31. (define pixmap '())            ; pixmap into which we draw
  32. (define continuation '())        ; where the computation left off
  33. (define work-proc-registered #f)    ; whether a work proc is registered
  34. (define window-origin '())        ; coordinates of upper left corner
  35. (define quantum '())            ; how much real space each pixel represents
  36. (define ncolors 16)            ; how many colors to use
  37.  
  38.  
  39. ; Define widgets
  40.  
  41. (define top-level
  42.   (if (defined? vs:top-level)
  43.       (xt:app-create-shell "xmandel" "Xmandel"
  44.                xt:application-shell
  45.                (xt:display vs:top-level))
  46.       (xt:initialize "xmandel" "Xmandel")))
  47.  
  48. (xt:set-values top-level xm:n-allow-shell-resize #t)
  49.  
  50. (define panel
  51.   (xt:create-managed-widget
  52.    "top" xm:form top-level))
  53.  
  54. (define controls
  55.   (xt:create-managed-widget
  56.    "control" xm:form panel
  57.    xm:n-left-attachment xm:attach-form
  58.    xm:n-top-attachment xm:attach-form
  59.    xm:n-bottom-attachment xm:attach-form))
  60.  
  61. (define button-frame
  62.   (xt:create-managed-widget
  63.    "button-frame" xm:frame controls
  64.    xm:n-left-attachment xm:attach-form
  65.    xm:n-right-attachment xm:attach-form
  66.    xm:n-top-attachment xm:attach-form))
  67.  
  68. (define button-box
  69.   (xt:create-managed-widget
  70.    "button-box" xm:row-column button-frame
  71.    xm:n-orientation xm:vertical
  72.    xm:n-num-columns 2
  73.    xm:n-packing xm:pack-column))
  74.  
  75. (define reset-button
  76.   (make-button
  77.    "Reset" button-box
  78.    (lambda (w)
  79.      (origin-object 'set origin)
  80.      (magnification-object 'set magnification)
  81.      (depth-object 'set depth)
  82.      (xt:set-values restart-button xm:n-sensitive #f))))
  83.  
  84. (define restart-button
  85.   (make-button
  86.    "Restart" button-box
  87.    (lambda (w)
  88.      (resize-handler drawing-area)
  89.      #t)))
  90.  
  91. (define (value-change-handler w)
  92.   (xt:set-values
  93.    restart-button
  94.    xm:n-sensitive
  95.    (not
  96.     (and
  97.      (= origin (origin-object 'get))
  98.      (= depth (depth-object 'get))
  99.      (= magnification (magnification-object 'get))))))
  100.  
  101. (define paused #f)
  102.  
  103. (define pause-button
  104.   (make-toggle-button
  105.    "Pause" button-box
  106.    (lambda (w)
  107.      (let ((old-paused paused))
  108.        (set! paused (xt:get-value w xm:n-set xt:boolean))
  109.        (if (and old-paused (not paused))
  110.        (register-work-proc))))
  111.    xm:n-shadow-thickness 2))
  112.  
  113. (define exit-button
  114.   (make-button
  115.    "Exit" button-box
  116.    (lambda (w)
  117.      (set! continuation '())
  118.      (if (defined? vs:top-level)
  119.      (xt:unmap-widget top-level)
  120.      (quit)))))
  121.  
  122. (define param-frame
  123.   (xt:create-managed-widget
  124.    "param-frame" xm:frame controls
  125.    xm:n-left-attachment xm:attach-form
  126.    xm:n-right-attachment xm:attach-form
  127.    xm:n-top-attachment xm:attach-widget
  128.    xm:n-top-widget button-frame
  129.    xm:n-bottom-attachment xm:attach-form))
  130.  
  131. (define param-box
  132.   (xt:create-managed-widget
  133.    "param-box" xm:row-column param-frame
  134.    xm:n-orientation xm:vertical))
  135.  
  136. ; This function creates an origin object, consisting of two sliders (one
  137. ; for the imaginary axis and one for the real axis), some state variables,
  138. ; and a method dispatch function.  The object responds to three messages:
  139. ;
  140. ;  (origin-object 'get)        returns complex origin defined by sliders
  141. ;  (origin-object 'set o)    sets sliders to specified origin
  142. ;  (origin-object 'rescale w h)    rescales sliders so they both appear in
  143. ;                 the middle and so the sliders exactly span
  144. ;                 the specified range (which is typically the
  145. ;                 drawing area)
  146. ;
  147. (define (make-origin)
  148.   (let* ((digits 3)
  149.      (mult (expt 10 digits))
  150.      (widget-value
  151.       (lambda (value)
  152.         (inexact->exact (round (* mult value)))))
  153.      (x-widget
  154.       (xt:create-managed-widget
  155.        "origin-x" xm:scale param-box
  156.        xm:n-orientation xm:horizontal
  157.        xm:n-minimum (widget-value -2)
  158.        xm:n-maximum (widget-value 2)
  159.        xm:n-value 0
  160.        xm:n-decimal-points digits
  161.        xm:n-show-value #t
  162.        xm:n-title-string (xm:string-create "Real origin")))
  163.      (y-widget
  164.       (xt:create-managed-widget
  165.        "origin-y" xm:scale param-box
  166.        xm:n-orientation xm:horizontal
  167.        xm:n-minimum (widget-value -2)
  168.        xm:n-maximum (widget-value 2)
  169.        xm:n-value 0
  170.        xm:n-decimal-points digits
  171.        xm:n-show-value #t
  172.        xm:n-title-string (xm:string-create "Imaginary origin"))))
  173.     (letrec
  174.     ((self
  175.       (lambda (selector . args)
  176.         (case selector
  177.           ((get)
  178.            (let ((sx
  179.               (/ (xt:get-value x-widget xm:n-value xt:integer) mult))
  180.              (sy
  181.               (/ (xt:get-value y-widget xm:n-value xt:integer) mult)))
  182.          (make-rectangular sx sy)))
  183.           ((set)
  184.            (let ((x (real-part (car args)))
  185.              (y (imag-part (car args))))
  186.          (xt:set-values x-widget xm:n-value (widget-value x))
  187.          (xt:set-values y-widget xm:n-value (widget-value y)))
  188.            (value-change-handler x-widget)
  189.            (value-change-handler y-widget))
  190.           ((rescale)
  191.            (let* ((real-width (car args))
  192.               (real-height (cadr args))
  193.               (origin (self 'get))
  194.               (ox (real-part origin))
  195.               (oy (imag-part origin)))
  196.          (xt:set-values
  197.           x-widget xm:n-minimum (widget-value (- ox (/ real-width 2))))
  198.          (xt:set-values
  199.           x-widget xm:n-maximum (widget-value (+ ox (/ real-width 2))))
  200.          (xt:set-values
  201.           y-widget xm:n-minimum (widget-value (- oy (/ real-width 2))))
  202.          (xt:set-values
  203.           y-widget xm:n-maximum (widget-value (+ oy (/ real-width 2))))))
  204.           (else (error "invalid origin method" selector))))))
  205.       (xt:add-callback x-widget xm:n-value-changed-callback value-change-handler)
  206.       (xt:add-callback y-widget xm:n-value-changed-callback value-change-handler)
  207.       self)))
  208.  
  209. (define origin-object (make-origin))
  210.  
  211. ; This function creates a magnification object, which consists of a slider and
  212. ; a get method.
  213. ;
  214. (define (make-magnification initial)
  215.   (let* ((digits 4)
  216.      (mult (expt 10 digits))
  217.      (widget-value
  218.       (lambda (value)
  219.         (inexact->exact (round (* mult value)))))
  220.      (widget
  221.       (xt:create-managed-widget
  222.        "magnification" xm:scale param-box
  223.        xm:n-orientation xm:horizontal
  224.        xm:n-minimum (inexact->exact (* .1  mult))
  225.        xm:n-maximum (inexact->exact (* 40 mult))
  226.        xm:n-value (widget-value initial)
  227.        xm:n-decimal-points digits
  228.        xm:n-show-value #t
  229.        xm:n-title-string (xm:string-create "Magnification"))))
  230.     (xt:add-callback widget xm:n-value-changed-callback value-change-handler)
  231.     (lambda (selector . args)        ; args not (yet) used
  232.       (case selector
  233.     ((get) (/ (xt:get-value widget xm:n-value xt:integer) mult))
  234.     ((set) (xt:set-values widget xm:n-value (widget-value (car args))))
  235.     (else (error "invalid origin method" selector))))))
  236.  
  237. (define magnification-object (make-magnification .1))
  238.  
  239. ; This function creates and returns a depth object, which consists of a slider
  240. ; and a get method.
  241. ;
  242. (define (make-depth initial)
  243.   (let* ((widget
  244.       (xt:create-managed-widget
  245.        "depth" xm:scale param-box
  246.        xm:n-orientation xm:horizontal
  247.        xm:n-minimum 1
  248.        xm:n-maximum 200
  249.        xm:n-value initial
  250.        xm:n-decimal-points 0
  251.        xm:n-show-value #t
  252.        xm:n-title-string (xm:string-create "Depth"))))
  253.     (xt:add-callback widget xm:n-value-changed-callback value-change-handler)
  254.     (lambda (selector . args)        ; args not (yet) used
  255.       (case selector
  256.     ((get) (xt:get-value widget xm:n-value xt:integer))
  257.     ((set) (xt:set-values widget xm:n-value (car args)))
  258.     (else (error "invalid origin method" selector))))))
  259.  
  260. (define depth-object (make-depth 20))
  261.                 
  262. (define drawing-frame
  263.   (xt:create-managed-widget
  264.    "frame" xm:frame panel))
  265.  
  266. (define drawing-area
  267.   (xt:create-managed-widget
  268.    "drawing-area" xm:drawing-area drawing-frame))
  269.  
  270. (xt:set-values
  271.  drawing-frame
  272.  xm:n-top-attachment xm:attach-form
  273.  xm:n-bottom-attachment xm:attach-form
  274.  xm:n-right-attachment xm:attach-form
  275.  xm:n-left-attachment xm:attach-widget
  276.  xm:n-left-widget controls)
  277.  
  278. (xt:realize-widget top-level)
  279.  
  280. (define xwindow (xt:window drawing-area))
  281. (define xdisplay (xt:display drawing-area))
  282. (define xgc1 (x:create-gc xdisplay '() x:gc-foreground 0 x:gc-background 1))
  283. (define    xgc2 (x:create-gc xdisplay '() x:gc-foreground 1 x:gc-background 0))
  284. (define display-colors (x:display-cells xdisplay 0))
  285.  
  286.  
  287. ;;; The cursor in the drawing area is a cross-hair.  If the user presses
  288. ;;; MB2 in the drawing area, we track motion events (until MB2 is released)
  289. ;;; and force the origin sliders to the point the cursor is on.
  290.  
  291. (x:define-cursor xdisplay (xt:window drawing-area) xc:crosshair)
  292.  
  293. (xt:add-event-handler
  294.  drawing-area x:button-press-mask 0
  295.  (lambda (widget event)
  296.    (let ((button (x:get-event-field event x:button-event:button)))
  297.      (if (= button 2)
  298.      (let* ((x (x:get-event-field event x:button-event:x))
  299.         (y (x:get-event-field event x:button-event:y))
  300.         (button-origin
  301.          (make-rectangular (+ (real-part window-origin)
  302.                       (* quantum x))
  303.                    (- (imag-part window-origin)
  304.                       (* quantum y))))
  305.          (tracker
  306.           (lambda (widget event)
  307.             (let* ((x (x:get-event-field event x:motion-event:x))
  308.                (y (x:get-event-field event x:motion-event:y))
  309.                (new-origin
  310.                 (make-rectangular (+ (real-part window-origin)
  311.                          (* quantum x))
  312.                           (- (imag-part window-origin)
  313.                          (* quantum y)))))
  314.               (origin-object 'set new-origin)))))
  315.        (origin-object 'set button-origin)
  316.        (xt:add-event-handler drawing-area x:pointer-motion-mask 0 tracker)
  317.        (xt:add-event-handler
  318.         drawing-area x:button-release-mask 0
  319.         (lambda (widget event)
  320.           (let ((button (x:get-event-field event x:button-event:button)))
  321.         (if (= button 2)
  322.             (xt:remove-event-handler
  323.              drawing-area x:pointer-motion-mask 0 tracker))))))))))
  324.           
  325. (xt:set-values panel xm:n-width 600 xm:n-height 400)
  326.  
  327. (define cmap (x:default-colormap xdisplay 0))
  328. (define private-colormap #f)
  329.  
  330. (define planes-n-colors
  331.   (x:alloc-color-cells xdisplay cmap #t 0 ncolors))
  332.  
  333. (if (not planes-n-colors)        ; if we couldn't allocate enuf cells
  334.     (begin
  335.       (set! cmap (x:create-colormap xdisplay (xt:window drawing-area) 0))
  336.       (set! planes-n-colors (x:alloc-color-cells xdisplay cmap #t 0 ncolors))
  337.       (set! private-colormap #t)))
  338.  
  339. (if (not planes-n-colors)
  340.     (error "Failed utterly to allocate required 16 colors"))
  341.  
  342. (define base-pixel (car (reverse (cadr planes-n-colors))))
  343.  
  344. (let ((i base-pixel))
  345.   (for-each
  346.    (lambda (item)
  347.      (let ((red (car item))
  348.        (green (cadr item))
  349.        (blue (caddr item)))
  350.        (x:store-color xdisplay cmap i red green blue)
  351.        (set! i (1+ i))))
  352.    '((    0     0     0)        ; colors - edit to taste (there
  353.      (60000     0 65000)        ; must be ncolors entries though)
  354.      (40000     0 60000)
  355.      (20000     0 55000)
  356.      (15000     0 50000)
  357.      (10000     0 45000)
  358.      ( 8000     0 40000)
  359.      ( 5000     0 35000)
  360.      ( 1000     0 30000)
  361.      (  500     0 25000)
  362.      (    0     0 20000)
  363.      (    0     0 15000)
  364.      (    0     0 10000)
  365.      (    0     0  8000)
  366.      (    0     0  6000)
  367.      (    0     0  4000))))
  368.  
  369. (if private-colormap
  370.     (xt:add-event-handler
  371.      drawing-area x:enter-window-mask 0
  372.      (lambda (widget event)
  373.        (x:install-colormap xdisplay cmap)
  374.        (xt:add-event-handler
  375.     drawing-area x:leave-window-mask 0
  376.     (lambda (widget event)
  377.       (x:install-colormap
  378.        xdisplay
  379.        (x:default-colormap xdisplay 0)))))))
  380.  
  381. ; The real (compute-intensive) work of computing the points to draw
  382. ; is performed in a work procedure called by Xt and registered with
  383. ; xt:add-work-proc (XtAddWorkProc).  The global variable "continuation"
  384. ; contains a continuation for the initiation  or resumption of this
  385. ; computation.  The work procedure calls compute-set (the first time)
  386. ; using call/cc and passing a continuation by which the Xt main loop
  387. ; can be resumed (so the program still handles user input).  compute-set
  388. ; computes for a while (currently 16 points) and then calls the
  389. ; continuation of the work proc with call/cc;   the work proc saves
  390. ; this continuation and the work proc resumes it each time it's
  391. ; called.  When compute-set finishes, it returns #t, which instructs
  392. ; the work proc to return #f, which instructs Xt to deregister it.
  393. ;
  394. ; There is also a global "paused" flag, which can be turned on by
  395. ; clicking a pause button -- useful if the machine's bogging down
  396. ; and you want to quit computing for a while.
  397.  
  398. (define (register-work-proc)
  399.   (xt:add-work-proc work-proc)
  400.   (set! work-proc-registered #t))
  401.  
  402. (define (work-proc)
  403.   (cond ((null? continuation)            ; computing not yet started
  404.      (set! continuation (call/cc compute-set))
  405.      #f)
  406.     ((or paused (eqv? #t continuation))    ; computing finished or paused
  407.      (set! work-proc-registered #f)
  408.      #t)
  409.     (else                    ; computing in progress
  410.      (continuation '())
  411.      #f)))
  412.  
  413. ; To speed things up, we just compute points and store them by color in a vector,
  414. ; drawing the points and emptying the vector at the end of each row.
  415. ;
  416. (define (compute-set contin)
  417.   (set! origin (origin-object 'get))
  418.   (set! depth (depth-object 'get))
  419.   (set! magnification (magnification-object 'get))
  420.   (set! quantum (/ 1 (* (min width height) magnification)))
  421.   (let* ((lastcolor '())
  422.      (real-width (* width quantum))
  423.      (real-height (* height quantum))
  424.      (x-increment (make-rectangular quantum 0))
  425.      (y-increment (make-rectangular 0 quantum))
  426.      (points (make-vector ncolors '()))
  427.      (complex-zero (make-rectangular 0 0)))
  428.     (set! window-origin (make-rectangular
  429.              (- (real-part origin) (/ real-width 2))
  430.              (+ (imag-part origin) (/ real-height 2))))
  431.     (origin-object 'rescale real-width real-height)
  432.     (do ((y 0 (1+ y))
  433.      (k0 window-origin (- k0 y-increment)))
  434.     ((=? y height) #t)
  435.       (do ((x 0 (1+ x))
  436.        (k k0 (+ k x-increment)))
  437.       ((=? x width) #t)
  438.     (let ((z complex-zero))
  439.       (do ((i 0 (1+ i)))
  440.           ((or (= i depth)
  441.            (>= (magnitude z) 4))
  442.            (let ((color
  443.               (modulo
  444.                (inexact->exact (truncate (magnitude z)))
  445.                ncolors))
  446.              (point (cons x y)))
  447.          (vector-set!
  448.           points color (cons point (vector-ref points color))))
  449.            #t)
  450.         (let ((term (+ z k)))
  451.           (set! z (* term term))))
  452.       (if (zero? (modulo x 16))        ; every 16 points, let XtMainLoop run
  453.           (call/cc contin))))
  454.       (do ((i 0 (1+ i)))            ; end of row, draw saved points
  455.       ((= i ncolors) #t)
  456.     (if (not (null? (vector-ref points i)))
  457.         (begin
  458.           (x:set-foreground xdisplay xgc2 (+ base-pixel i))
  459.           (if (xt:is-realized drawing-area)
  460.           (apply
  461.            x:draw-points
  462.            `(,xdisplay
  463.              ,(xt:window drawing-area)
  464.              ,xgc2 ,x:coord-mode-origin
  465.              ,@(vector-ref points i))))
  466.           (apply
  467.            x:draw-points
  468.            `(,xdisplay
  469.          ,pixmap ,xgc2 ,x:coord-mode-origin
  470.          ,@(vector-ref points i)))
  471.           (vector-set! points i '())))))))
  472.  
  473. ; The resize handler allocates a new pixmap of the correct size and
  474. ; restarts the computation.
  475. ;
  476. (define (resize-handler w)
  477.   (set! height (xt:get-value w xt:n-height xt:unsigned-short))
  478.   (set! width (xt:get-value w xt:n-width xt:unsigned-short))
  479.   (if (not (null? pixmap))
  480.       (x:free-pixmap xdisplay pixmap))
  481.   (set! pixmap
  482.     (x:create-pixmap
  483.      xdisplay '() width height
  484.      (x:display-depth xdisplay 0)))
  485.   (x:fill-rectangle xdisplay pixmap xgc1 0 0 width height)
  486.   (x:clear-area xdisplay xwindow 0 0 0 0 #t)
  487.   (xt:set-values restart-button xm:n-sensitive #f)
  488.   (set! continuation '())
  489.   (if (not work-proc-registered)
  490.       (register-work-proc)))
  491.  
  492. (resize-handler drawing-area)
  493.  
  494. ; The expose handler just copies from the pixmap onto the window
  495. ;
  496. (define (exposure-handler widget e)
  497.   (let ((x (x:get-event-field e x:expose-event:x))
  498.     (y (x:get-event-field e x:expose-event:y))
  499.     (w (x:get-event-field e x:expose-event:width))
  500.     (h (x:get-event-field e x:expose-event:height)))
  501.     (x:copy-area xdisplay pixmap (xt:window widget)
  502.          xgc1 x y w h x y)))
  503.  
  504. (xt:add-event-handler drawing-area x:exposure-mask 0 exposure-handler)
  505. (xt:add-callback drawing-area xm:n-resize-callback resize-handler)
  506.  
  507. (register-work-proc)
  508.  
  509. (if (not (defined? vs:top-level))
  510.     (xt:main-loop))
  511.